# see copyright and information at http://code.google.com/p/perl-ctx/
# http and https protocol realization.

# error codes:
# 10 - connection unexpectedly closed
# 11 - url missing;
package Net::Coro::EV::HTTP;
use common::sense;
our $VERSION = 0.04;

use EV;
use Net::SSLeay;
use HTTP::Response;

use URI::Escape qw(uri_escape_utf8);
use HTML::Entities();
use HTML::Form();
use Encode qw(encode);
use HTTP::Request();
use HTTP::Headers();
use HTTP::Cookies();
use Net::Coro::EV::Connect::Socket;

our $BINDIP = 0;

our $REPEAT = 3;
our $TIMEOUT = 20; # seconds; in KA state restart for each request; 
our $PROTOCOL = "HTTP/1.1";
our $REDIRECT = 7;
our $META_REFRESH = 0;
our %HEADERS = (
	'User-Agent' => "Mozilla/5.0 (compatible; U; Net-Coro-HTTP/$VERSION; search.cpan.org/perldoc?Net::Coro::HTTP)",
	'Accept' => 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8',
	'Accept-Language' => 'en-us;q=0.7,en;q=0.3',
	'Accept-Encoding' => 'gzip,deflate',
	'Accept-Charset' => 'utf-8;q=0.7,*;q=0.7',
	'Keep-Alive' => 115,
	'Connection' => 'keep-alive',
	'Pragma' => 'no-cache',
	'Cache-Control' => 'no-cache',
);


my $meta_preredir = qr/http-equiv\s*=\s*["']?refresh/is;
my $meta_redir = qr/<\s*meta\s+http-equiv\s*=\s*["']?refresh["']?.*content\s*=\s*['"]\s*0\s*;\s*url=(.*?)['"> ]/si;


use constant {
	
	PTS_NONE => 0,
	PTS_CONNECT => 1,
	PTS_READ => 2,
	PTS_READ_BODY => 3,
	PTS_READ_CHUNK => 4,
	PTS_KEEPALIVE => 5,
	PTS_WRITE => 6,

	CHN_START => 0,
	CHN_READ => 1,
	
	TRACE_URL => 1,
	TRACE_REQUSET => 2,
	TRACE_RESPONSE => 4,
};
sub new {
	my ($class, $socket) = @_;
	$class = ref($class) || $class;	

	my $this = {};
	$this->{_STATE} = PTS_NONE;
	$this->{_STATE_CHUNK} = CHN_START;
	$this->{_CHUNK_PRE} = '';
	
	$socket = new Net::Coro::EV::Connect::Socket if !$socket;
	$this->{_SOCKET} = $socket;

	$this->{_PROTOCOL} = $PROTOCOL;
	$this->{_REDIRECT_INIT} = $REDIRECT;
	$this->{_IS_META_REDIRECT} =$META_REFRESH;
	$this->{_HEADERS} = \%HEADERS;
	$this->{_COOKIES} = HTTP::Cookies->new (ignore_discard => 1);

	$this->{_REPEAT_LIMIT} = $REPEAT;
	$this->{_REPEAT} = $this->{_REPEAT_LIMIT};
	$this->{_TRACE} = 0;

	bless $this, $class;
	$this->bindip($BINDIP) if $BINDIP;
	$this->timeout($TIMEOUT);
	$this->_headers;

	return $this;
}

sub trace {
	my ($this, $value) = @_;
	return $this->{_TRACE} if (! defined $value);
	$this->{_TRACE} = $value;
}

sub child {
	my ($this) = @_;
	
	my $child = {};
	bless $child, ref $this;
		
	while (my ($key, $val) = each(%$this)) {
		$child->{$key} = $val;
	}
	$child->{_SOCKET} = $this->{_SOCKET}->child;
	
	$child->{_STATE} = PTS_NONE;
	delete $child->{_WIO};
	delete $child->{_WTM};
	delete $child->{_TLS};

	return $child;	
}
sub socket {$_[0]->{_SOCKET}->child}
	
sub _request {
	my ($this, $request, $url, $scheme, $host, $port, $cb, @prm) = @_;	
	# is it redirect continue
	if (!$cb) {
		# or wrong request call
		die(__PACKAGE__." request: arguments count less then 2") if !$this->{_CB};
	}
	# or the firs request
	else {
			$this->{_REDIRECT} = $this->{_REDIRECT_INIT};
			$this->{_CB} = $cb;
			$this->{_PRM} = \@prm;
	}
	
	utf8::downgrade($url);
	utf8::downgrade($scheme); 
	utf8::downgrade($host);
	utf8::downgrade($port);
	

	if ($this->{_TRACE} & TRACE_URL) {
		my ($mehod) = $request =~ /^(\S+)/;
		print "TRACE[".time."] $this->{_ID} HTTP: $mehod $url\n";
	}
	print "TRACE[".time."] $this->{_ID} HTTP: $request\n" if $this->{_TRACE} & TRACE_REQUSET;
	
	$this->{_REQUEST} = $request;
	$this->{_URL} = $url;
	$this->{_SCHEME} = $scheme;

	undef $this->{_RESPONSE};
	$this->{_RESPONSE_PART}='';
	$this->{_RESPONSE_BODY} = '';
	$this->{_RESPONSE_HEADERS} = {};
	undef $this->{_RESPONSE_VARS} ;
	undef $this->{_TLS_WRITED} ;
	
	# if  keepalive and prev addres the same use KA  else (close and) create new  
	if (($this->{_STATE} == PTS_KEEPALIVE) and ($host eq $this->{_HOST} and $port == $this->{_PORT})){
		if ($scheme eq 'https') {
			$this->tls_request();
		}
		$this->{_STATE} = PTS_WRITE;
		$this->{_WIO}->events (EV::WRITE);
		$this->{_WTM}->set($this->{_TIMEOUT}, $this->{_TIMEOUT});
		$this->{_WTM}->start();
	} else {
		$this->close if ($this->{_STATE} == PTS_KEEPALIVE);
		$this->{_HOST} = $host;
		$this->{_PORT} = $port;
		$this->{_STATE} = PTS_CONNECT;
			
		# create tsl/ssl session if https
		if ($scheme eq 'https') {
			$this->new_tls();
			$this->tls_request();
		}
		$this->{_SOCKET}->connect($host, $port, $this);
	}
}

sub onconnect {
	my ($this, $wio, $wtm, $serv_ip, $serv_port) = @_;
	return $this->err($this->{_SOCKET}->errm, $this->{_SOCKET}->errc) if !$wio;
	
	$this->{_WIO} = $wio;
	$this->{_WTM} = $wtm;
	
	$this->{_WIO}->data($this);
	$this->{_WIO}->events (EV::WRITE);
}

sub onwrite {
	my ($this) = @_;
	# support https
	my $request ;
	if (defined $this->{_TLS}) {
		$request = $this->{_TLS_REQUEST} ;
	} else {
		$request = $this->{_REQUEST};
		$request =~ s/^(\w+\s+)http:\/\/\S+?\//$1\//s;
	}

	
	utf8::downgrade($request);
	return $request;
}

sub new_tls {
	my ($this) = @_;
	
	# init tls/ssl context
	if (!$this->{_TLS_CTX}) {
		Net::SSLeay::load_error_strings();
		Net::SSLeay::SSLeay_add_ssl_algorithms();
		Net::SSLeay::randomize();
		
		$this->{_TLS_CTX} = Net::SSLeay::CTX_new();
		Net::SSLeay::CTX_set_options ($this->{_TLS_CTX}, Net::SSLeay::OP_ALL());
	}
	
	# init tls/ssl session
	my $tls = $this->{_TLS} = Net::SSLeay::new ($this->{_TLS_CTX});
	Net::SSLeay::set_connect_state ($tls);
	Net::SSLeay::CTX_set_mode ($tls, 1|2); #  need for non-blocking ( MODE_ENABLE_PARTIAL_WRITE | MODE_ACCEPT_MOVING_WRITE_BUFFER)
	my $rbio = $this->{_TLS_RBIO} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
	my $wbio = $this->{_TLS_WBIO} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
	Net::SSLeay::set_bio ($tls, $rbio, $wbio);
}

sub tls_request {
	my ($this) = @_;
	
	if (!$this->{_TLS_WRITED}) {
		my $request = $this->{_REQUEST};
		my $tmp;
		while (($tmp = Net::SSLeay::write ($this->{_TLS}, $request)) > 0) {
			substr $request, 0, $tmp, '';
		}
		# if $tmp <=0 (in fact -1) than assume handshake stage (this is not error)
		$this->{_TLS_WRITED} = 1 if !length($request); # finaly write request
	}
	$this->{_TLS_REQUEST} = Net::SSLeay::BIO_read ($this->{_TLS_WBIO});
}

sub onread {
	my ($this, $response) = @_;	# plain text

	# check if https
	if (defined $this->{_TLS}) {
		Net::SSLeay::BIO_write ($this->{_TLS_RBIO}, $response);
		$response = undef;
		my $tmp_resp;
		while (!!($tmp_resp = Net::SSLeay::read ($this->{_TLS}))) {
			### check length if 0 - error or end (shoudl not ever happen)
			$response .= $tmp_resp;
		}

		# check if handshake stage
		if (!$response) {
			$this->{_WIO}->events (EV::WRITE) if $this->tls_request(); # else leave EV::READ
			
			#my $tsl_state = Net::SSLeay::state($this->{_TLS});
			#if ($tsl_state == Net::SSLeay::ST_OK()) {
			#	$this->{_WIO}->events (EV::WRITE) if ($this->{_STATE} == PTS_CONNECT or $this->{_STATE} == PTS_WRITE);
			#} elsif ($tsl_state != 4400 and $tsl_state != 4416 and $tsl_state != 4384) {	# by RFC should be 4560
			#	$this->{_WIO}->events (EV::WRITE);
			#}
			
			return;
		}
	}
		
	# chek if it continued
	if ($this->{_STATE} == PTS_READ) {
		$this->{_RESPONSE_BODY} .= $response;
		return; # continue read from socket, callback wil be executed on end connection in onclose() method
	}
	
	# for chunked response
	elsif ($this->{_STATE} == PTS_READ_CHUNK) {
		return if ($this->read_chunk($response));
	}
	
	# for content-lenhgth response
	elsif ($this->{_STATE} == PTS_READ_BODY) {
		$this->{_RESPONSE_BODY} .= $response;
		#check if end
		return if (length($this->{_RESPONSE_BODY}) < $this->{_RESPONSE_HEADERS}->{'content-length'});
	}
	
	elsif ($this->{_STATE} == PTS_CONNECT or $this->{_STATE} == PTS_WRITE ) {
		# cut headers
		$this->{_RESPONSE_PART} .= $response;
		my ($version, $code, $msg, $headers_str, $content) = $this->{_RESPONSE_PART} =~ /^(\S+)\s+(\d+)\s+(.*?)\r?\n(.+?\r?\n)\r?\n(.*)$/s;
		if (!$headers_str) {
			# check if response without headers
			($version, $code, $msg, $content) = $this->{_RESPONSE_PART} =~ /^(\S+)\s+(\d+)\s+(.*?)\r?\n\r?\n(.*)$/s;
			if (defined $version) {
				$this->{_RESPONSE_VARS} = [$version, $code, $msg];
				$this->{_STATE} = PTS_READ;
				$this->{_RESPONSE_BODY} = $content || "";
			}
			return ;
		} else {
			delete $this->{_RESPONSE_PART} ;
		}

		print "TRACE[".time."] $this->{_ID} HTTP: response - $version $code $msg\n$headers_str\n" if $this->{_TRACE} & TRACE_RESPONSE;

		my (%headers, $hdr);
		while ($headers_str =~ /\G(?:(\S+):\s*)?(.*?)\s*\r?\n/gs) {
			if (!$1) {
				$headers{$hdr} .= " $2";
			} else {
				$hdr = lc($1);
				if (! defined $headers{$hdr}){
					$headers{$hdr} = $2;
				} elsif (ref $headers{$hdr}){
					push @{$headers{$hdr}}, $2;
				} else {
					$headers{$hdr} = [$headers{$hdr}, $2];
				}
 			}
		}
		
		# issue of some buggy web servers.
		delete $headers{''};
		
		$this->{_RESPONSE_VARS} = [$version, $code, $msg];
		$this->{_RESPONSE_HEADERS} = \%headers;
		
		# process cunked response
		my $te = $headers{'transfer-encoding'};
		if ((defined $te) and $te eq 'chunked') {
			$this->{_STATE_CHUNK} = CHN_START;
			$this->{_STATE} = PTS_READ_CHUNK;
			return if ($this->read_chunk($content));
		}
		
		# check for Content-Length header  else check for close connection
		elsif (defined(my $cl = $headers{'content-length'})) {
			$this->{_RESPONSE_BODY} = $content;
			if (length($this->{_RESPONSE_BODY}) < $cl) {
				$this->{_STATE} = PTS_READ_BODY;
				return ;
			}
		} 
		
		# posibly not KeepAlive response
		else {
			$this->{_RESPONSE_BODY} = $content;
			$this->{_STATE} = PTS_READ;
			return ; # continue read from socket, untill it closed by peer
		}
	}
	else { # for debug
		my @cllr = caller;
		warn("proto->response: uncknown state: ".$this->{_STATE}."; 
		caller: $cllr[0] $cllr[1] $cllr[2] 
		resp:{".$response."}\n request:{".$this->{_REQUEST}."}");
		return ; # continue read from socket till timeout
	}

	# keep alive socket until it will be closed by remote host
	$this->{_STATE} = PTS_KEEPALIVE;
	$this->{_WTM}->stop();
	
	my $conn = $this->{_RESPONSE_HEADERS}->{'connection'};
	if ((defined $conn) and ($conn eq 'close')) {
		$this->close; # _STATE changed to ST_NONE
	}
	
	# callback
	$this->callback(); 
	return;
}

# return 0 for end
# return 1 for continue
sub read_chunk {
	my ($this, $body) = @_;
	
	# check for  start chunk (CHN_START) else suppose CHN_READ and continue read chunk
	my $chunk;
	if ($this->{_STATE_CHUNK} == CHN_START) {
		#get chunk lsize
		$body = $this->{_CHUNK_PRE}.$body;
		
		do {	
			$body =~ s/^\r?\n//s;
			return 1 if (!$body);
		
			my ($chn_size_hex, $body_tmp) = $body =~ /^(\w+).*?\r?\n(.*)/s;
			if (!defined($chn_size_hex)) {
				$this->{_CHUNK_PRE} = $body;
				return 1;
			}
			$this->{_CHUNK_PRE} = '';
			
			eval {
			$this->{_CHUNK_SIZE} = hex($chn_size_hex);
			};
			if ($@) {				
				if (my ($prx_host, $prx_port) = $this->{_SOCKET}->address()) {
					$this->err("unexpected chunk, possibly buggy proxy $prx_host:$prx_port", 10);
					return 1;
				} else {
					print "CATCH DEBUG ERROR, CHANK READING SAY: $@\n";
					print "DEB BODY (\$this->{_RESPONSE_BODY}): $this->{_RESPONSE_BODY}\n";
					print "DEB BODY (\$body): $body\n";
					print "DEB URL : $this->{_URL} \n";
					die ($@);
				}
			}
			
			# chek for end
			if ($this->{_CHUNK_SIZE} == 0) {
				# process headers.
				# to do
				return 0;
			}

			$body = $body_tmp;
			$chunk = substr $body, 0, $this->{_CHUNK_SIZE}, '';
			$this->{_RESPONSE_BODY} .= $chunk;
		} while ($body);
		
	} else {
		$chunk = substr $body, 0, $this->{_CHUNK_SIZE}, '';
		$this->{_RESPONSE_BODY} .= $chunk;
		if ($body) {
			$this->{_STATE_CHUNK} = CHN_START;
			return $this->read_chunk($body);
		}
	}
	
	$this->{_STATE_CHUNK} = CHN_READ;
	$this->{_CHUNK_SIZE} -= length($chunk);
	return 1;
}



####### COMMON ARCHITECTURAL METHODS AND EVENT HANDLERS #######
sub callback {
	my ($this) = @_;

	print "TRACE[".time."] $this->{_ID} HTTP: DONE - success\n" if ($this->{_TRACE} & TRACE_URL);
	
	# extract cookies
	if (defined $this->{_RESPONSE_HEADERS}->{"set-cookie"} or
		defined $this->{_RESPONSE_HEADERS}->{"set-cookie2"}) {
		$this->{_COOKIE_TRICK}->set_cookie($this->{_RESPONSE_HEADERS}->{"set-cookie"});
		$this->{_COOKIE_TRICK}->set_cookie2($this->{_RESPONSE_HEADERS}->{"set-cookie2"});
		$this->{_COOKIES}->extract_cookies($this->{_COOKIE_TRICK});
	}
	
	if (defined $this->{_RESPONSE_HEADERS}->{'content-encoding'}) {
		my @headers = (%{$this->{_RESPONSE_HEADERS}});
		$this->{_RESPONSE} = HTTP::Response->new($this->{_RESPONSE_VARS}->[1], 
			"$this->{_RESPONSE_VARS}->[0] $this->{_RESPONSE_VARS}->[1] $this->{_RESPONSE_VARS}->[2]", \@headers );
		$this->{_RESPONSE}->content($this->{_RESPONSE_BODY});
		$this->{_BODY} = $this->{_RESPONSE}->decoded_content();
	} else {
		$this->{_BODY} = $this->{_RESPONSE_BODY};
	}
		
	# chek for redirect
	my $url;
	if ($this->{_RESPONSE_VARS}->[1] =~ /^30[1237]/s) {
		$url = $this->{_RESPONSE_HEADERS}->{'location'};
	}
	elsif (!!$this->{_IS_META_REDIRECT}) {
		# sometimes _BODY may have illegal utf8 character 
		# it throws warning while processing regexp $meta_preredir
		# so we turn off this warnings
		no warnings qw(utf8);
		if ($this->{_RESPONSE_HEADERS}->{'content-type'} =~ /html/ and $this->{_BODY} =~ $meta_preredir) {
			if (my ($encurl) = $this->{_BODY} =~ $meta_redir) {
				$url = HTML::Entities::decode($encurl);
				#$url =~ s/'//sg;
				undef $this->{_REFERER};
			}
		}
	}
	

	if ($this->{_REDIRECT} && $url) {
		$this->{_REDIRECT}--;
#		$url =~ s/^(https?:\/\/[\w\.\-]+)\?/$1\/\?/s; # mail.ru issue
#		return $this->err("no_redirect_url; $url", 11) if ($url !~ /^https?:/);
		# in case if HTTP onbject is child inhereted from this package - we need to call parent get function 
		return get ($this, $url); # $this->{_CB}, @{$this->{_PRM}});
	}

	# call back
	$this->{_REFERER} = $this->{_URL};
	$this->{_REPEAT} = $this->{_REPEAT_LIMIT};
	undef $this->{_ERRM};
	undef $this->{_ERRC};
	delete $this->{_ERR};
	(delete $this->{_CB})->($this, 
		$this->{_BODY}, $this->{_URL}, $this->{_RESPONSE_VARS}->[1],
		@{delete $this->{_PRM}}
	);
}

sub response {
	my ($this) = @_;
	if (!$this->{_RESPONSE}) {
		my @headers = (%{$this->{_RESPONSE_HEADERS}});
		$this->{_RESPONSE} = HTTP::Response->new($this->{_RESPONSE_VARS}->[1], 
			"$this->{_RESPONSE_VARS}->[0] $this->{_RESPONSE_VARS}->[1] $this->{_RESPONSE_VARS}->[2]", \@headers );
		$this->{_RESPONSE}->content($this->{_RESPONSE_BODY});
	}
	
	return $this->{_RESPONSE};
}

sub err {
	my ($this, $msg, $code) = @_;
	$this->{_ERRM} = $msg;
	$this->{_ERRC} = $code;

	# close all
	$this->close;
	
	# send error
	my @prm = @{delete $this->{_PRM}};
	my $cb = delete $this->{_CB};
	
	# retry request several times if get cannel error. useful for bad channels
	if ($code==2 and $this->{_REPEAT}--) {
		print "TRACE[".time."] $this->{_ID} HTTP: DONE - error (left tryes $this->{_REPEAT}) $code|$msg (state=$this->{_STATE})\n" if ($this->{_TRACE} & TRACE_URL) or ($this->{_TRACE} & TRACE_RESPONSE);
		$this->{_SOCKET}->stop();
		return $this->_request(
			$this->{_REQUEST},
			$this->{_URL},
			$this->{_SCHEME},
			$this->{_HOST},
			$this->{_PORT},
			$cb,
			@prm
		);
	}
	
	print "TRACE[".time."] $this->{_ID} HTTP: DONE - error $code|$msg (state=$this->{_STATE})\n" if ($this->{_TRACE} & TRACE_URL) or ($this->{_TRACE} & TRACE_RESPONSE);
	$this->{_REPEAT} = $this->{_REPEAT_LIMIT};
	my $errcb = delete $this->{_ERR};
	if (!$errcb) {
		$cb->($this,undef,$msg,$code,$cb, @prm);
	} 
	else {
		$errcb->($this,$msg,$code,$cb,$errcb, @prm);
	}
}

sub onwritten {
	my ($this, $w) = @_;
	$w->events (EV::READ);
}

sub onclose {
	my ($this) = @_;
	# make desigion what to do
	# default is to send error
	
	my $state = $this->{_STATE};
	#  deside what to do
	if ($state == PTS_READ) {
		$this->close;
		$this->callback(); 
	}
	else {
		$this->onbreak("connectnion closed by http host", 10);
	}
}

sub onbreak {
	my ($this, $msg, $code) = @_;
	$code = 2 if !$code;
	
	my $state = $this->{_STATE};
	#  deside what to do
	if ($state == PTS_READ) {
		$this->err("PTS_READ: ".$msg, $code);
	}
	elsif ($state == PTS_CONNECT) {
		$this->err("PTS_CONNECT: ".$msg, $code);
	}
	elsif ($state == PTS_READ_BODY) {
		$this->err("PTS_READ_BODY: ".$msg, $code);
	}
	elsif ($state == PTS_READ_CHUNK) {
		$this->err("PTS_READ_CHUNK: ".$msg, $code);
	}
	elsif ($state == PTS_KEEPALIVE) {
		# can be activity on socket or timeout
		# do nothing. just close
		$this->close;
	}
	elsif ($state == PTS_WRITE) {
		$this->close;
		# reconnect
		$this->{_STATE} = PTS_CONNECT;
		
		undef $this->{_RESPONSE};
		$this->{_RESPONSE_PART}='';
		$this->{_RESPONSE_BODY} = '';
		$this->{_RESPONSE_HEADERS} = {};
		undef $this->{_RESPONSE_VARS} ;
		undef $this->{_TLS_WRITED} ;

		# create tsl/ssl session if https
		if ($this->{_SCHEME} eq 'https') {
			$this->new_tls();
			$this->tls_request();
		}
		$this->{_SOCKET}->connect($this->{_HOST}, $this->{_PORT}, $this);
	}
}


sub close {
	my ($this) =@_;
	$this->{_STATE} = PTS_NONE;
	Net::SSLeay::free (delete $this->{_TLS}) if (defined $this->{_TLS});
	
	my $tm = delete $this->{_WTM};
	$tm->stop() if defined $tm;
	
	my $w = delete $this->{_WIO};
	if (defined $w) {
		$w->stop();
		my $fh = $w->fh;
		shutdown($fh, 2);
		CORE::close($fh);
	}
}

sub stop {
	my ($this) = @_;
	$this->{_SOCKET}->stop();
	$this->close();
	delete $this->{_CB};
	delete $this->{_ERR};
	delete $this->{_PRM};
}


sub error {
	my ($this, $cberr) = @_;
	$this->{_ERR} = $cberr;
}

### PUBLIC METHODS TO SET/GET REQUEST PROPIRTIES ######
sub timeout {
	my ($this, $val) = @_;	
	if (defined $val) {
		$this->{_TIMEOUT} = $val;
		$this->{_SOCKET}->timeout($val);
	}
	return $this->{_TIMEOUT};
}
sub timeout_conn {
	my ($this, $val) = @_;
	$this->{_SOCKET}->timeout($val);
}

sub protocol {
	my ($this, $val) = @_;	
	$this->{_PROTOCOL} = $val if defined $val;
	return $this->{_PROTOCOL};
}
sub redirect {
	my ($this, $val) = @_;	
	$this->{_REDIRECT_INIT} = $val if defined $val;
	return $this->{_REDIRECT_INIT};
}
sub meta_refresh {
	my ($this, $val) = @_;	
	$this->{_IS_META_REDIRECT} = $val if defined $val;
	return $this->{_IS_META_REDIRECT};
}
sub user_agent {$_[0]->request_header('User-Agent', $_[1])}
sub request_header {
	my ($this, $key, $val) = @_;
	return $this->{_HEADERS}->{$key} if !defined($val);
	$this->{_HEADERS}->{$key} = $val;
	$this->_headers;
}
sub _headers {
	my ($this) = @_;
	$this->{_HEADERS_STR} ='';
	while (my($key,$value) = each(%{$this->{_HEADERS}})) {
		$this->{_HEADERS_STR} .= "$key: $value\r\n";
	}
}

sub response_headers {$_[0]->{_RESPONSE_HEADERS}}

sub cookies {
	my ($this, $val) = @_;	
	$this->{_COOKIES} = $val if defined $val;
	return $this->{_COOKIES};
}
sub referer {
	my ($this, $val) = @_;	
	$this->{_REFERER} = $val if defined $val;
	return $this->{_REFERER};
}

sub body {
	$_[0]->{_BODY} = $_[1] if $_[1];
	$_[0]->{_BODY};
}
sub url {$_[0]->{_URL}}
sub code {$_[0]->{_RESPONSE_VARS}->[1]}

sub errc {$_[0]->{_ERRC}}
sub errm {$_[0]->{_ERRM}}

sub id {
	my ($this, $id) = @_;
	if (defined $id) {
		$this->{_ID} = $id;
		$this->{_SOCKET}->id($id);
	}
	$this->{_ID};
}
sub bindip {$_[0]->{_SOCKET}->bindip($_[1])}

sub repeat {
	my ($this, $val) = @_;
	$this->{_REPEAT_LIMIT} = $val if (defined $val) ;
	$this->{_REPEAT_LIMIT};
}

# $cb - can be empty when redirect. but $this->{_CB} already presents
sub get {
	my ($this, $url, $cb, @prm) = @_;
	
	if (!$url) {
		# check if not redirect
		if (!!$cb) {
			$this->{_CB} = $cb;
			$this->{_PRM} = \@prm;
		}
		return $this->err("GET: url missing", 11);
	}
	
	$url =~ s/#.*//s;	# remove fragment
	my ($scheme, $host, $port, $path, $query) = $url =~ m|^(https?)://([^/?#:]*)(?::(\d+))?(/[^\?]*)?\??(.*)|si;
	# if  url is relative, than we compose full path and reparse
	if (!$scheme) {
		($scheme, $host, $port) = ($this->{_SCHEME}, $this->{_HOST}, $this->{_PORT});
		$url =~ s/^\.\/+//; # delete first dot if any
		my $url_base;
		if ($url =~ s/^\///) {
			# url relative  to the root dir
			$url_base = $this->{_SCHEME}.'://'.$this->{_HOST}.':'.$this->{_PORT};
		} else {
			# url relative  to the current dir
			$url_base .= $this->{_URL};
			$url_base =~ s/\/[^\/]*$//;
		}
		$url = "$url_base/$url";
		($path, $query) = $url =~ m|^https?://[^/?#:]+(?::\d+)?(/[^\?]*)?\??(.*)|si;
		
		# check if realy port was exists
		($port) = $this->{_URL} =~ m|^https?://[^/?#:]*(?::(\d+))|s;
	}
	
	$url = $path || "/";
	if ($query) {
		$url .=	"?";
		
		$query =~ s/\+/ /sg;
		my @params = split ('&',$query); 
		foreach (@params) {
			my ($key, $value) = split ('=',$_, 2);
			$key =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/egs;
			$value =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/egs;
			$url .=	uri_escape_utf8($key).'='.uri_escape_utf8($value)."&";
		}
		chop($url);
	}
	
	$scheme = lc $scheme;
	$host = lc $host;

	
	# RFC 2616, section 15.1.3.
	# https -> http redirect, suppressing Referer
	undef $this->{_REFERER} if !!$this->{_SCHEME} and ($this->{_SCHEME} eq 'https' and $scheme eq 'http');

	my $request = "GET $url $this->{_PROTOCOL}\r\n";
	$request .= "Host: $host\r\n";
	$request .= "Referer: $this->{_REFERER}\r\n" if !!$this->{_REFERER};
	$request .= $this->{_HEADERS_STR};
	
	$url = "$scheme://$host".($port?":$port":"").$url;
	$port=($scheme eq 'https')?443:80 if !$port;
	# set cookie
	$this->{_COOKIE_TRICK} = Net::Coro::EV::HTTP::CookieTrick->new ($url, $scheme, $host, $port);
	$this->{_COOKIES}->add_cookie_header($this->{_COOKIE_TRICK});
	# $request .= $this->{_COOKIE_TRICK}->cookie2;
	$request .= $this->{_COOKIE_TRICK}->cookie;
	$request .= "\r\n";

	$this->_request($request, $url, $scheme, $host, $port, $cb, @prm);
}


sub request {
	my ($this, $request, $cb, @prm) = @_;
	my $uri = $request->uri;
	my $url = $uri->as_string;
	if (!$url) {
		$this->{_CB} = $cb;
		$this->{_PRM} = \@prm;
		return $this->err("GET: url missing", 11);
	}

	my ($scheme, $host, $port) = ($uri->scheme, $uri->host, $uri->port);
	$url =~ s/#.*//s;	# remove fragment
	
	$this->{_COOKIE_TRICK} = Net::Coro::EV::HTTP::CookieTrick->new ($url, $scheme, $host, $port);
	# RFC 2616, section 15.1.3.
	# https -> http redirect, suppressing Referer
	undef $this->{_REFERER} if !!$this->{_SCHEME} and ($this->{_SCHEME} eq 'https' and $scheme eq 'http');

	$request->protocol( $this->{_PROTOCOL}) if !$request->protocol;
	$request->header(%{$this->{_HEADERS}});
	$request->init_header(Host => $host);
	$request->_header('Referer', $this->{_REFERER}) if !$request->_header('Referer');
	$this->{_COOKIES}->add_cookie_header($request);	
	
	my $strreq = $request->as_string("\r\n");
	$strreq =~ s/^(\w+\s+)https?:\/\/$host/$1/s;
	$this->_request($strreq, $url, $scheme, $host, $port, $cb, @prm);
}

sub set_def {
	my ($this, $request) = @_;
	$request->protocol($this->{_PROTOCOL}) if !$request->protocol;
	$request->header(%{$this->{_HEADERS}});
	$request->_header('Host' => $request->uri->host);

	# RFC 2616, section 15.1.3.
	# https -> http redirect, suppressing Referer
	if (!!$this->{_SCHEME} and ($this->{_SCHEME} eq 'https' and $request->uri->scheme eq 'http')) {
		$request->remove_header('Referer');
	} else {
		$request->_header('Referer',$this->{_REFERER});
	}
	$this->{_COOKIES}->add_cookie_header($request);	
}


sub pure_request {
	my ($this, $request, $cb, @prm) = @_;
	my $uri = $request->uri;
	my $url = $uri->as_string;
	if (!$url) {
		$this->{_CB} = $cb;
		$this->{_PRM} = \@prm;
		return $this->err("GET: url missing", 11);
	}


	my ($scheme, $host, $port) = ($uri->scheme, $uri->host, $uri->port);
	$url =~ s/#.*//s;	# remove fragment
	
	my $strreq = $request->as_string("\r\n");
	$strreq =~ s/^(\w+\s+)https?:\/\/$host/$1/s;
	$this->_request($strreq, $url, $scheme, $host, $port, $cb, @prm);
}



sub form {
	my ($this, $data, $formsign, $addtext, $cb, @prm) = @_;
	
	my $form = $this->form_get($formsign, $addtext);
	return if (!$form);
	$this->form_fill($form, $data);
	$this->request($form->click, $cb, @prm);
	return 1;
}

# static helper method
sub form_get {
	my ($this, $signature, $addtext) = @_;
	$signature = "." if !$signature;
	
	my $content = $this->body . "</form>";
	my @forms = $content =~ /(<\s*form.*?<\/\s*form\s*>)/gis;
	
	my @forms_tmp = grep {/$signature/s} @forms;
	return if !@forms_tmp;
	
	$forms_tmp[0] =~ s/(<\/\s*form\s*>)/$addtext$1/gsi if defined $addtext;
	
	my $encoding = "utf8";
	my $resp = $this->response;
	if ($resp->can("content_charset")) {
		$encoding = $resp->content_charset;
	} else {
		# support old version libwww
		if (my $hdr = $resp->header("Content-Type")) {
			$encoding = $1 if $hdr =~ /charset=(\S+)/s;
		}
	}

	my $form;
	if (($encoding =~ /utf/si) or !$encoding) {
		$form = HTML::Form->parse($forms_tmp[0], $this->url);
	} else {
		my $txt = encode($encoding, $forms_tmp[0]);
		$form = HTML::Form->parse(
			$txt, 
			base => $this->url,
			charset => $encoding
		);
	}
	my $action = $form->action;
	$action =~ s/\#.*//s;
	$form->action($action );
	return $form;
}

# key can be:
#  - name
#  :N - order num form top
#  :-N - order num from bottom
#
# value can be:
#  - value
# :on / :of - for check box
# :N - order num for possible values (select)
# :enable - to enable
# :enable:value - to enable and insert value
# :_name - the value of named input
# :random - select possible_value for multiple input 
sub form_fill {
	my ($this, $form, $data) = @_;
	die("form_fill : \$form is not specified") if !$form;
	
	while( my ($k, $v) = each %$data ) {
		my $input;
		if ($k =~ /^:/) {
			if ($k =~ /^:(\d+)/) {
				$input = $form->find_input((undef, undef, $1));
			}
			if ($k =~ /^:-(\d+)/) {
				my @inputs = $form->inputs;
				$input = $form->find_input((undef, undef, scalar(@inputs) - $1));
			}
		} else {
			$input = $form->find_input($k);
		}
		
		if (defined($input) && $input && defined($v)) {
			if ($v =~ /^:/) {
				($v eq ':random') && $input->value(($input->possible_values)[int rand scalar($input->possible_values)]);
				($v eq ':random1') && $input->value(($input->possible_values)[1+int( rand( scalar( $input->possible_values) - 1))]);
				($v eq ':on') && $input->check;
				($v eq ':off') && $input->value(undef);
				($v =~ /^:(\d+)/) && $input->value(($input->possible_values)[$1]);
				if ($v =~ /^:enable/) {
					$input->disabled(0);
					($v =~ /^:enable:(.*)/) && $input->value($1);
				}
				
				($v =~ /^:_(.*)/) && $input->value($form->value($1));
				
			} else {
				$input->value($v);
			}
		}
	}
}



package Net::Coro::EV::HTTP::CookieTrick;
use common::sense;
sub new {
	my ($class, $url, $scheme, $host, $port, $setcookie, $setcookie2) = @_;
	my ($path) = $url =~ m!^\w+://.*?/(.*/)!s;
	$path = "/".($path || '');
	my $this = [
		$scheme, $host, $port, $path,
		{"Set-Cookie2" => $setcookie, "Set-Cookie" => $setcookie2},
		{"Host" => $host, "Cookie"=>''},
		{Cookie=>'', Cookie2=>''}
	];
	bless $this, $class;
	return $this;
}
sub set_cookie {$_[0]->[4]->{"Set-Cookie"}=$_[1]}
sub set_cookie2 {$_[0]->[4]->{"Set-Cookie2"}=$_[1]}
sub cookie {
	if (my $cookie = $_[0]->[6]->{Cookie}) {
		return "Cookie: ".$cookie."\r\n";
	}
}
sub cookie2 {
	if (my $cookie = $_[0]->[6]->{Cookie2}) {
		return "Cookie2: ".$cookie."\r\n";
	}
}

# return "Set-Cookie2" or "Set-Cookie"
sub _header {
	my $coockie = $_[0]->[4]->{$_[1]};
	return @$coockie if ref $coockie;
	return $coockie;
}

sub request {$_[0]}

sub header {
	my ($this, $key, $value) = @_;
	# if $key   "Host" or "Cookie"
	return $this->[5]->{$key} if !$value;
	
	# if $key Cookie or Cookie2
	$this->[6]->{$key} = $value;
}
sub uri {$_[0]}
*url = \&uri;

sub scheme {$_[0]->[0]}
sub host {$_[0]->[1]}
sub port {$_[0]->[2]}
sub epath {$_[0]->[3]}
*path = \&epath;


1;